home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / interp / extern.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  26.2 KB  |  818 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (C) 1994, Carnegie Mellon University
  4. *  All rights reserved.
  5. *
  6. *  This code was produced by the Gwydion Project at Carnegie Mellon
  7. *  University.  If you are interested in using this code, contact
  8. *  "Scott.Fahlman@cs.cmu.edu" (Internet).
  9. *
  10. ***********************************************************************
  11. *
  12. * $Header: extern.c,v 1.2 94/11/30 16:17:18 rgs Exp $
  13. *
  14. * This file provides support for manipulating native C pointers.
  15. *
  16. \**********************************************************************/
  17.  
  18. #include "../compat/std-c.h"
  19.  
  20. #include "mindy.h"
  21. #include "gc.h"
  22. #include "obj.h"
  23. #include "bool.h"
  24. #include "char.h"
  25. #include "list.h"
  26. #include "type.h"
  27. #include "class.h"
  28. #include "def.h"
  29. #include "sym.h"
  30. #include "module.h"
  31. #include "error.h"
  32. #include "thread.h"
  33. #include "func.h"
  34. #include "extern.h"
  35. #include "num.h"
  36. #include "str.h"
  37. #include "print.h"
  38. #include "coll.h"
  39. #ifdef hp9000s800
  40. #include <sys/file.h>
  41. /*
  42. #include <stdio.h>
  43. #include <stdlib.h>
  44. */
  45. #include <a.out.h>
  46. #include <aouthdr.h>
  47. #include <filehdr.h>
  48. #include <syms.h>
  49. #include <sys/mman.h>
  50. #include <unistd.h>
  51. #endif
  52.  
  53. obj_t obj_CPointerClass = NULL;      /* all instances of StaticTypeClass are
  54.                      subclasses of this one */
  55. obj_t obj_ForeignFileClass = NULL;
  56. obj_t obj_NullPointer = NULL;
  57. obj_t /* <foreign-file> */ mindy_explicit_syms = NULL;
  58.  
  59. static obj_t /* <foreign-file> */ mindy_dynamic_syms = NULL;
  60.  
  61. obj_t make_c_pointer(obj_t /* <static-pointer-class> */ cls, void *ptr)
  62. {
  63.     obj_t res = alloc(cls, sizeof(struct c_pointer));
  64.  
  65.     C_PTR(res)->pointer = ptr;
  66.  
  67.     return res;
  68. }
  69.  
  70. /* Dylan routines. */
  71.  
  72. /* Reads the symtab (in some machine specific format) from the named file 
  73.    and returns a "foreign_file" object which allows access to those symbols */
  74. obj_t  load_c_symtab(obj_t /* <string> */ abs_file)
  75. { 
  76.     int fd, count, total = 0;
  77.     char *file = string_chars(abs_file);
  78.     obj_t res;
  79.     
  80. #if defined(hp9000s800)
  81.     struct header hdr;
  82.     struct symtab *retval;
  83.     int sym_count, sym_size, sym_loc, string_size, string_loc, table_size;
  84.     struct symbol_dictionary_record *syms;
  85.     char *strings;
  86.     int i, j;
  87.  
  88.     /* Read beginning of "file" into "hdr" */
  89.     fd = open(file, O_RDONLY, 0);
  90.     if (fd < 0) return 0;
  91.     for (count = read(fd, ((char *)&hdr), sizeof(hdr)), total = count;
  92.      count > 0 && total < sizeof(hdr);
  93.      count = read(fd, ((char *)&hdr + total), sizeof(hdr) - total),
  94.      total += count) ;
  95.     if (total < sizeof(hdr)) return 0;
  96.  
  97.     /* Read in symbol table */
  98.     sym_count = hdr.symbol_total;
  99.     sym_loc = hdr.symbol_location;
  100.     sym_size = sizeof(struct symbol_dictionary_record) * sym_count;
  101.     if ((syms = (struct symbol_dictionary_record *) malloc(sym_size)) == NULL)
  102.     return 0;
  103.     if (lseek(fd, sym_loc, 0) < 0) return 0;
  104.     for (count = read(fd, (char *) syms, sym_size), total = count;
  105.      count > 0 && total < sym_size;
  106.      count = read(fd, ((char *) syms) + total, sym_size - total),
  107.      total += count) ;
  108.     if (total < sym_size) return 0;
  109.  
  110.     string_size = hdr.symbol_strings_size;
  111.     table_size = (sym_count - 1) * sizeof(struct symtab);
  112.     res = alloc(obj_ForeignFileClass,
  113.         sizeof(struct foreign_file) + table_size + string_size);
  114.     FOREIGN_FILE(res)->extra_size = string_size + table_size;
  115.  
  116.     retval = FOREIGN_FILE(res)->syms;
  117.     strings = (char *)retval + table_size;
  118.  
  119.     /* Read in symbol table strings */
  120.     string_loc = hdr.symbol_strings_location;
  121.     if (lseek(fd, string_loc, 0) < 0) return 0;
  122.     for (count = read(fd, strings, string_size), total = count;
  123.      count > 0 && total < string_size;
  124.      count = read(fd, strings + total, string_size - total),
  125.      total += count) ;
  126.     if (total < string_size) return 0;
  127.  
  128.     close(fd);
  129.  
  130.     if (retval == NULL) return 0;
  131.     for (i = 0, j = 0; i < sym_count; i++)
  132.     if (syms[i].symbol_scope == SS_UNIVERSAL) {
  133.         retval[j].name = strings + syms[i].name.n_strx;
  134.         switch (syms[i].symbol_type) {
  135.         case ST_DATA:
  136.         retval[j++].ptr = (void *) syms[i].symbol_value;
  137.         break;
  138.         case ST_CODE:
  139.         case ST_PRI_PROG:
  140.         case ST_SEC_PROG:
  141.         case ST_ENTRY:
  142.         case ST_MILLICODE:
  143.         retval[j++].ptr = (void *) (syms[i].symbol_value & 0xfffffffc);
  144.         break;
  145.         default:
  146.         retval[j++].ptr = 0;
  147.         }
  148.     }
  149.  
  150.     FOREIGN_FILE(res)->file_name = abs_file;
  151.     FOREIGN_FILE(res)->sym_count = j;
  152.  
  153.     return res;
  154. #else
  155.     return obj_False;
  156. #endif
  157. }
  158.  
  159. /* Links the named object files for dynamic loading, reads it in, and returns
  160.    a "foreign_file" object which allows access to its symbols.  If
  161.    names is a non-empty list (of byte-strings), then make ld "undefine"
  162.    these names so that they will show up in the linked version. */
  163. obj_t load_c_file(obj_t /* list */ c_files, obj_t /* list */ names)
  164. /* c_file is a <string> */
  165. {
  166. #ifdef hp9000s800
  167.     char *execstr;
  168.     int execlimit = 1024, execsize;
  169.     char *absfile;
  170.     obj_t res, file_name = obj_False;
  171.     static int pagesize = 0;
  172.     int fd, count, total, codesize, bss_size, mapresult;
  173.     struct header hdr;
  174.     struct som_exec_auxhdr aux;
  175.     static void *addr = (void *)0x20000000;
  176.  
  177.     if (pagesize == 0) pagesize = sysconf(_SC_PAGE_SIZE);
  178.  
  179.     execstr = malloc(execlimit);
  180.     absfile = tmpnam(NULL);
  181.     sprintf(execstr, "/bin/ld -N -o %s -E -A %s -R %x",
  182.         absfile, exec_file_name, (int) addr);
  183.     execsize = strlen(execstr);
  184.     /* append each object file */
  185.     for ( ; c_files != obj_Nil; c_files = TAIL(c_files)) {
  186.     int flaglen = obj_ptr(struct string *, HEAD(c_files))->len + 1;
  187.     if ((execsize + flaglen + 1) > execlimit) {
  188.         execlimit += 1024;
  189.         execstr = realloc(execstr, execlimit);
  190.     }
  191.     if (file_name == obj_False) file_name = HEAD(c_files);
  192.     sprintf(execstr+execsize, " %s", string_chars(HEAD(c_files)));
  193.     execsize += flaglen;
  194.     }
  195.     /* undefine each of the names we were given */
  196.     for ( ; names != obj_Nil; names = TAIL(names)) {
  197.     int flaglen = obj_ptr(struct string *, HEAD(names))->len + 4;
  198.     if ((execsize + flaglen + 1) > execlimit) {
  199.         execlimit += 1024;
  200.         execstr = realloc(execstr, execlimit);
  201.     }
  202.     sprintf(execstr+execsize, " -u %s", string_chars(HEAD(names)));
  203.     execsize += flaglen;
  204.     }
  205.     if (system(execstr) != 0)
  206.     return NULL;        /* unknown failure */
  207.     
  208.     /* Read beginning of "file" into "hdr" */
  209.     fd = open(absfile, O_RDONLY, 0);
  210.     if (fd < 0) return 0;
  211.     for (count = read(fd, ((char *)&hdr), sizeof(hdr)), total = count;
  212.      count > 0 && total < sizeof(hdr);
  213.      count = read(fd, ((char *)&hdr + total), sizeof(hdr) - total),
  214.      total += count) ;
  215.     if (total < sizeof(hdr)) return NULL;
  216.  
  217.     if (lseek(fd, hdr.aux_header_location, 0) < 0) return NULL;
  218.     for (count = read(fd, ((char *)&aux), sizeof(aux)), total = count;
  219.      count > 0 && total < sizeof(aux);
  220.      count = read(fd, ((char *)&aux + total), sizeof(aux) - total),
  221.      total += count) ;
  222.     if (total < sizeof(aux)) return NULL;
  223.  
  224.     codesize = ((aux.exec_tsize + pagesize - 1) / pagesize) * pagesize;
  225.     mapresult =
  226.     (int) mmap((void *) aux.exec_tmem, codesize,
  227.            PROT_READ | PROT_WRITE | PROT_EXEC,
  228.            MAP_FIXED | MAP_PRIVATE | MAP_FILE, fd, aux.exec_tfile);
  229.     if (mapresult < 0)
  230.     return NULL;
  231.     if (aux.exec_tmem + codesize > (int)addr)
  232.     addr = (void *)(aux.exec_tmem + codesize);
  233.     
  234.     codesize = ((aux.exec_dsize + pagesize - 1) / pagesize) * pagesize;
  235.     if (mmap((void *)aux.exec_dmem, codesize,
  236.          PROT_READ | PROT_WRITE | PROT_EXEC,
  237.          MAP_FIXED | MAP_PRIVATE | MAP_FILE, fd, aux.exec_dfile) < 0)
  238.     return NULL;
  239.  
  240.     bss_size = ((aux.exec_bsize + pagesize - 1) / pagesize) * pagesize;
  241.     if (mmap((void *)(aux.exec_dmem + codesize), bss_size,
  242.          PROT_READ | PROT_WRITE | PROT_EXEC,
  243.          MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, -1, 0) < 0)
  244.     return NULL;
  245.     if (aux.exec_bfill != 0)
  246.     error("Non-zero BSS fill value -- must fix extern.c");
  247.     if (aux.exec_dmem + codesize + bss_size > (int)addr)
  248.     addr = (void *)(aux.exec_dmem + codesize + bss_size);
  249.  
  250.     close(fd);
  251.     
  252.     res = load_c_symtab(make_byte_string(absfile));
  253.     FOREIGN_FILE(res)->file_name = file_name;
  254.     unlink(absfile);
  255.     
  256.     return res;
  257. #else
  258.     error("Dynamic loading is not supported for this architecture.");
  259.     return obj_False;
  260. #endif
  261. }
  262.  
  263. static void print_foreign_file(obj_t file)
  264. {
  265.     printf("{<foreign-file> %s}", string_chars(FOREIGN_FILE(file)->file_name));
  266. }
  267.  
  268. static void print_c_pointer(obj_t ptr)
  269. {
  270.     obj_t class = C_PTR(ptr)->class;
  271.     obj_t class_name = obj_ptr(struct class *, class)->debug_name;
  272.     char *class_str;
  273.  
  274.     if (class_name != NULL && class_name != obj_False)
  275.     class_str = sym_name(class_name);
  276.     else
  277.     class_str = "<c-pointer>";
  278.  
  279.     printf("{%s 0x%08lx}", class_str, (unsigned long)(C_PTR(ptr)->pointer));
  280. }
  281.  
  282. /* Look for an object with the given name in the named file and return a
  283.    callable "<c-function>" object for it. */
  284. obj_t find_c_function(obj_t /* <string> */ symbol, obj_t lookup)
  285. {
  286.     char *string = string_chars(symbol);
  287.     struct symtab *syms;
  288.     int sym_count, i;
  289.     obj_t retval = obj_False;
  290.  
  291.     if (lookup == obj_Unbound) {
  292.     retval = find_c_function(symbol, mindy_explicit_syms);
  293.     if (retval != obj_False) return retval;
  294.  
  295.     if (mindy_dynamic_syms == NULL)
  296.         mindy_dynamic_syms = load_c_symtab(make_byte_string(exec_file_name));
  297.     return find_c_function(symbol, mindy_dynamic_syms);
  298.     } else if (lookup == obj_False)
  299.     return obj_False;
  300.     else if (object_class(lookup) != obj_ForeignFileClass) {
  301.     error("Keyword file: is not a <foreign-file>: %=", lookup);
  302.     return retval;        /* make lint happy */
  303.     } else {
  304.     syms = FOREIGN_FILE(lookup)->syms;
  305.     sym_count = FOREIGN_FILE(lookup)->sym_count;
  306.     for (i = 0; i < sym_count; i++)
  307.         if (strcmp(syms[i].name, string) == 0) {
  308.         retval = make_c_function(make_byte_string(string),
  309.                      syms[i].ptr);
  310.         break;
  311.         }
  312.     return retval;
  313.     }
  314. }
  315.  
  316. /* Look for an object with the given name in the named file and return a
  317.    "<c-pointer>" object for it. */
  318. obj_t find_c_ptr(obj_t /* <string> */ symbol, obj_t lookup)
  319. {
  320.     char *string = string_chars(symbol);
  321.     struct symtab *syms;
  322.     int sym_count, i;
  323.     obj_t retval = obj_False;
  324.  
  325.     if (lookup == obj_Unbound) {
  326.     retval = find_c_ptr(symbol, mindy_explicit_syms);
  327.     if (retval != obj_False) return retval;
  328.  
  329.     if (mindy_dynamic_syms == NULL)
  330.         mindy_dynamic_syms = load_c_symtab(make_byte_string(exec_file_name));
  331.     return find_c_ptr(symbol, mindy_dynamic_syms);
  332.     } else if (lookup == obj_False)
  333.     return obj_False;
  334.     else if (object_class(lookup) != obj_ForeignFileClass) {
  335.     error("Keyword file: is not a <foreign-file>: %=", lookup);
  336.     return retval;        /* make lint happy */
  337.     } else {
  338.     syms = FOREIGN_FILE(lookup)->syms;
  339.     sym_count = FOREIGN_FILE(lookup)->sym_count;
  340.     for (i = 0; i < sym_count; i++)
  341.         if (strcmp(syms[i].name, string) == 0) {
  342.         retval = make_c_pointer(obj_CPointerClass, syms[i].ptr);
  343.         break;
  344.         }
  345.     return retval;
  346.     }
  347. }
  348.  
  349. /* Tries to return a version of some Dylan object which will be
  350.    meaningful to C.  This may include a pointer, an integer, or
  351.    something else.  We assume that it can be freely cast to and from a
  352.    pointer. */
  353. void *get_c_object(obj_t obj)
  354. {
  355.     obj_t cls = object_class(obj);
  356.  
  357.     if (object_class(cls) == obj_StaticTypeClass)
  358.     return C_PTR(obj)->pointer;
  359.     else if (cls == obj_IntegerClass || cls == obj_FixnumClass)
  360.     return (void *)fixnum_value(obj);
  361.     else if (cls == obj_ByteStringClass)
  362.     return (void *)string_chars(obj);
  363.     else if (cls == obj_CharacterClass)
  364.     return (void *)(int)char_int(obj);
  365.     else if (cls == obj_BooleanClass)
  366.     return (void *)(obj != obj_False);
  367.     else
  368.     return NULL;
  369. }
  370.  
  371. /* Tries to convert a C return value back into a dylan object. */
  372. obj_t convert_c_object(obj_t cls, void *obj, boolean miss_ok)
  373. {
  374.     if (cls == obj_ObjectClass)
  375.     return make_c_pointer(obj_CPointerClass, obj);
  376.     else if (object_class(cls) == obj_StaticTypeClass)
  377.     return make_c_pointer(cls, obj);
  378.     else if (cls == obj_CFunctionClass)
  379.     return make_c_function(make_byte_string("(unknown)"), obj);
  380.     else if (cls == obj_IntegerClass || cls == obj_FixnumClass)
  381.     return make_fixnum((int) obj);
  382.     else if (cls == obj_ByteStringClass || cls == obj_StringClass)
  383.     return make_byte_string((char *)obj);
  384.     else if (cls == obj_CharacterClass)
  385.     return int_char((int)obj);
  386.     else if (cls == obj_BooleanClass)
  387.     return obj == NULL ? obj_False : obj_True;
  388.     else if (miss_ok)
  389.     return make_c_pointer(obj_CPointerClass, obj);
  390.     else {
  391.     error("Could not coerce c_pointer to class %=", cls);
  392.     return obj_NullPointer;
  393.     }
  394. }
  395.  
  396. obj_t signed_byte_at(obj_t /* <statically-typed-pointer> */ pointer,
  397.              obj_t /* <integer> */ offset)
  398. {
  399.     void *ptr = C_PTR(pointer)->pointer;
  400.     int true_offset = fixnum_value(offset);
  401.     
  402.     if (!obj_is_fixnum(offset))
  403.     error("Offset is not fixnum: %=", offset);
  404.     return make_fixnum(*((char *)((int)ptr + true_offset)));
  405. }
  406.  
  407. obj_t signed_byte_at_setter(obj_t /* <integer> */ value,
  408.                 obj_t /* <statically-typed-pointer> */ pointer,
  409.                 obj_t /* <integer> */ offset)
  410. {
  411.     void *ptr = C_PTR(pointer)->pointer;
  412.     int true_offset = fixnum_value(offset);
  413.     
  414.     if (!obj_is_fixnum(offset))
  415.     error("Offset is not fixnum: %=", offset);
  416.     *((char *)((int)ptr + true_offset)) = fixnum_value(value);
  417.     return value;
  418. }
  419.  
  420. obj_t unsigned_byte_at(obj_t /* <statically-typed-pointer> */ pointer,
  421.                obj_t /* <integer> */ offset)
  422. {
  423.     void *ptr = C_PTR(pointer)->pointer;
  424.     int true_offset = fixnum_value(offset);
  425.     
  426.     if (!obj_is_fixnum(offset))
  427.     error("Offset is not fixnum: %=", offset);
  428.     return make_fixnum(*((unsigned char *)((int)ptr + true_offset)));
  429. }
  430.  
  431. obj_t unsigned_byte_at_setter(obj_t /* <integer> */ value,
  432.                   obj_t /* <statically-typed-pointer> */ pointer,
  433.                   obj_t /* <integer> */ offset)
  434. {
  435.     void *ptr = C_PTR(pointer)->pointer;
  436.     int true_offset = fixnum_value(offset);
  437.     
  438.     if (!obj_is_fixnum(offset))
  439.     error("Offset is not fixnum: %=", offset);
  440.     *((unsigned char *)((int)ptr + true_offset)) = fixnum_value(value);
  441.     return value;
  442. }
  443.  
  444. obj_t signed_short_at(obj_t /* <statically-typed-pointer> */ pointer,
  445.               obj_t /* <integer> */ offset)
  446. {
  447.     void *ptr = C_PTR(pointer)->pointer;
  448.     int true_offset = fixnum_value(offset);
  449.     
  450.     if (!obj_is_fixnum(offset))
  451.     error("Offset is not fixnum: %=", offset);
  452.     return make_fixnum(*((short *)((int)ptr + true_offset)));
  453. }
  454.  
  455. obj_t signed_short_at_setter(obj_t /* <integer> */ value,
  456.                  obj_t /* <statically-typed-pointer> */ pointer,
  457.                  obj_t /* <integer> */ offset)
  458. {
  459.     void *ptr = C_PTR(pointer)->pointer;
  460.     int true_offset = fixnum_value(offset);
  461.     
  462.     if (!obj_is_fixnum(offset))
  463.     error("Offset is not fixnum: %=", offset);
  464.     *((short *)((int)ptr + true_offset)) = fixnum_value(value);
  465.     return value;
  466. }
  467.  
  468. obj_t unsigned_short_at(obj_t /* <statically-typed-pointer> */ pointer,
  469.             obj_t /* <integer> */ offset)
  470. {
  471.     void *ptr = C_PTR(pointer)->pointer;
  472.     int true_offset = fixnum_value(offset);
  473.     
  474.     if (!obj_is_fixnum(offset))
  475.     error("Offset is not fixnum: %=", offset);
  476.     return make_fixnum(*((unsigned short *)((int)ptr + true_offset)));
  477. }
  478.  
  479. obj_t unsigned_short_at_setter(obj_t /* <integer> */ value,
  480.                    obj_t /* <statically-typed-pointer> */ pointer,
  481.                    obj_t /* <integer> */ offset)
  482. {
  483.     void *ptr = C_PTR(pointer)->pointer;
  484.     int true_offset = fixnum_value(offset);
  485.     
  486.     if (!obj_is_fixnum(offset))
  487.     error("Offset is not fixnum: %=", offset);
  488.     *((unsigned short *)((int)ptr + true_offset)) = fixnum_value(value);
  489.     return value;
  490. }
  491.  
  492. obj_t signed_long_at(obj_t /* <statically-typed-pointer> */ pointer,
  493.              obj_t /* <integer> */ offset)
  494. {
  495.     void *ptr = C_PTR(pointer)->pointer;
  496.     int true_offset = fixnum_value(offset);
  497.     
  498.     if (!obj_is_fixnum(offset))
  499.     error("Offset is not fixnum: %=", offset);
  500.     return make_fixnum(*((long *)((int)ptr + true_offset)));
  501. }
  502.  
  503. obj_t signed_long_at_setter(obj_t /* <integer> */ value,
  504.                 obj_t /* <statically-typed-pointer> */ pointer,
  505.                 obj_t /* <integer> */ offset)
  506. {
  507.     void *ptr = C_PTR(pointer)->pointer;
  508.     int true_offset = fixnum_value(offset);
  509.     
  510.     if (!obj_is_fixnum(offset))
  511.     error("Offset is not fixnum: %=", offset);
  512.     *((long *)((int)ptr + true_offset)) = fixnum_value(value);
  513.     return value;
  514. }
  515.  
  516. obj_t unsigned_long_at(obj_t /* <statically-typed-pointer> */ pointer,
  517.                obj_t /* <integer> */ offset)
  518. {
  519.     void *ptr = C_PTR(pointer)->pointer;
  520.     int true_offset = fixnum_value(offset);
  521.     
  522.     if (!obj_is_fixnum(offset))
  523.     error("Offset is not fixnum: %=", offset);
  524.     return make_fixnum(*((unsigned long *)((int)ptr + true_offset)));
  525. }
  526.  
  527. obj_t unsigned_long_at_setter(obj_t /* <integer> */ value,
  528.                   obj_t /* <statically-typed-pointer> */ pointer,
  529.                   obj_t /* <integer> */ offset)
  530. {
  531.     void *ptr = C_PTR(pointer)->pointer;
  532.     int true_offset = fixnum_value(offset);
  533.     
  534.     if (!obj_is_fixnum(offset))
  535.     error("Offset is not fixnum: %=", offset);
  536.     *((unsigned long *)((int)ptr + true_offset)) = fixnum_value(value);
  537.     return value;
  538. }
  539.  
  540. obj_t pointer_at(obj_t /* <statically-typed-pointer> */ pointer,
  541.          obj_t /* <integer> */ offset,
  542.          obj_t /* <class> */ cls)
  543. {
  544.     void *ptr = C_PTR(pointer)->pointer;
  545.     int true_offset = fixnum_value(offset);
  546.     
  547.     if (!obj_is_fixnum(offset))
  548.     error("Offset is not fixnum: %=", offset);
  549.     if (!instancep(cls, obj_StaticTypeClass))
  550.     error("class is not statically typed pointer: %=", cls);
  551.     /* pointer size object -- dereference as (void **) */
  552.     return convert_c_object(cls, *(void **)((char *)ptr + true_offset),
  553.                 FALSE);
  554. }
  555.  
  556. obj_t pointer_at_setter(obj_t /* <statically-typed-pointer> */ value,
  557.             obj_t /* <statically-typed-pointer> */ pointer,
  558.             obj_t /* <integer> */ offset)
  559. {
  560.     void *ptr = C_PTR(pointer)->pointer;
  561.     int true_offset = fixnum_value(offset);
  562.     
  563.     if (!obj_is_fixnum(offset))
  564.     error("Offset is not fixnum: %=", offset);
  565.     /* pointer size object -- dereference as (void **) */
  566.     *((void **)((char *)ptr + true_offset)) = get_c_object(value);
  567.     return value;
  568. }
  569.  
  570. obj_t pointer_add(obj_t /* <statically-typed-pointer> */ pointer,
  571.           obj_t /* <integer> */ num)
  572. {
  573.     void *ptr = C_PTR(pointer)->pointer;
  574.     int true_offset = fixnum_value(num);
  575.     
  576.     return make_c_pointer(object_class(pointer),
  577.               (void *)((int)ptr + true_offset));
  578. }
  579.     
  580. obj_t pointer_subtract(obj_t /* <statically-typed-pointer> */ pointer1,
  581.                obj_t /* <statically-typed-pointer> */ pointer2)
  582. {
  583.     void *ptr1 = C_PTR(pointer1)->pointer;
  584.     void *ptr2 = C_PTR(pointer2)->pointer;
  585.     
  586.     return make_fixnum((long int)ptr1 - (long int)ptr2);
  587. }
  588.     
  589.  
  590. /* Dereferences a "slot" in the "structure" pointed to by a <c-pointer>. */
  591. obj_t c_pointer_field(obj_t pointer, obj_t offset, obj_t cls, obj_t deref)
  592. {
  593.     void *ptr = C_PTR(pointer)->pointer;
  594.     int true_offset = fixnum_value(offset);
  595.  
  596.     if (deref == obj_False)
  597.     /* Don't dereference -- just increment */
  598.     return convert_c_object(cls, (void *)((int)ptr + true_offset), FALSE);
  599.     else if (cls == obj_CharacterClass || cls == obj_BooleanClass)
  600.     /* byte size object -- dereference as (char *) */
  601.     return convert_c_object(cls, (void *)*((char *)ptr + true_offset),
  602.                 FALSE);
  603.     else
  604.     /* pointer size ofject -- dereference as (void **) */
  605.     return convert_c_object(cls, *(void **)((char *)ptr + true_offset),
  606.                 FALSE);
  607. }
  608.  
  609. /* Sets the value of a "slot" in the "structure" pointed to by a */
  610. /* <c-pointer>. */
  611. obj_t c_pointer_field_setter(obj_t value, obj_t /* <c-pointer> */ pointer,
  612.                  obj_t /* <integer> */ offset)
  613. {
  614.     obj_t cls = object_class(value);
  615.     void *ptr = C_PTR(pointer)->pointer;
  616.     int true_offset = fixnum_value(offset);
  617.  
  618.     if (cls == obj_CharacterClass || cls == obj_BooleanClass)
  619.     /* byte size object -- dereference as (char *) */
  620.     *((char *)ptr + true_offset) = ((char) get_c_object(value));
  621.     else
  622.     /* pointer size ofject -- dereference as (void **) */
  623.     *((void **)((char *)ptr + true_offset)) = get_c_object(value);
  624.     return value;
  625. }
  626.  
  627. obj_t c_pointer_as(obj_t /* <class> */ cls,
  628.            obj_t /* <statically-typed-pointer> */ object)
  629. {
  630.     if (instancep(object, cls))
  631.     return object;
  632.     else
  633.     return make_c_pointer(cls, C_PTR(object)->pointer);
  634. }
  635.  
  636. obj_t c_ptr_as_int(obj_t /* <class> */ cls,
  637.            obj_t /* <statically-typed-pointer> */ object)
  638. {
  639.     return make_fixnum((int) C_PTR(object)->pointer);
  640. }
  641.  
  642. obj_t c_int_as_ptr(obj_t /* <class> */ cls,
  643.            obj_t /* <integer> */ object)
  644. {
  645.     if (instancep(object, cls))
  646.     return object;
  647.     else
  648.     return make_c_pointer(cls, (void *)fixnum_value(object));
  649. }
  650.  
  651. obj_t c_pointer_equal(obj_t left, obj_t right)
  652. {
  653.     if (C_PTR(left)->pointer == C_PTR(right)->pointer)
  654.     return obj_True;
  655.     else
  656.     return obj_False;
  657. }
  658.  
  659. /* GC routines. */
  660.  
  661. int scav_c_pointer(struct object *obj)
  662. {
  663.     return sizeof(struct c_pointer);
  664. }
  665.  
  666. obj_t trans_c_pointer(obj_t cptr)
  667. {
  668.     return transport(cptr, sizeof(struct c_pointer));
  669. }
  670.  
  671. static int scav_foreign_file(struct object *obj)
  672. {
  673.     scavenge(&((struct foreign_file *)obj)->file_name);
  674.     return sizeof(struct foreign_file)
  675.     + ((struct foreign_file *)obj)->extra_size;
  676. }
  677.  
  678. static obj_t trans_foreign_file(obj_t cptr)
  679. {
  680.     return transport(cptr, sizeof(struct foreign_file)
  681.                     + FOREIGN_FILE(cptr)->extra_size);
  682. }
  683.  
  684. void scavenge_c_roots(void)
  685. {
  686.     scavenge(&obj_CPointerClass);
  687.     scavenge(&obj_ForeignFileClass);
  688.     scavenge(&obj_NullPointer);
  689.     if (mindy_dynamic_syms != NULL)
  690.     /* Let it be scavenged and we'll recreate it at need */
  691.     mindy_dynamic_syms = NULL;
  692.     scavenge(&mindy_explicit_syms);
  693. }
  694.  
  695.  
  696. /* Init stuff. */
  697.  
  698. void make_c_classes(void)
  699. {
  700.     obj_CPointerClass
  701.     = make_builtin_class(scav_c_pointer, trans_c_pointer);
  702.     CLASS(obj_CPointerClass)->class = obj_StaticTypeClass;
  703.     CLASS(obj_CPointerClass)->sealed_p = FALSE;
  704.     obj_ForeignFileClass
  705.     = make_builtin_class(scav_foreign_file, trans_foreign_file);
  706. }
  707.  
  708. void init_c_classes(void)
  709. {
  710.     init_builtin_class(obj_CPointerClass, "<statically-typed-pointer>",
  711.                obj_ObjectClass, NULL);
  712.     def_printer(obj_CPointerClass, print_c_pointer);
  713.     init_builtin_class(obj_ForeignFileClass, "<foreign-file>", obj_ObjectClass,
  714.                NULL);
  715.     def_printer(obj_ForeignFileClass, print_foreign_file);
  716. }
  717.  
  718. void init_c_functions(void)
  719. {
  720.     extern void build_explicit_syms(void);
  721.     
  722.     /* This is required by find_c_function and find_c_pointer */
  723.     build_explicit_syms();
  724.     
  725.     define_method("find-c-function",
  726.           list1(obj_ByteStringClass), FALSE,
  727.           list1(pair(symbol("file"), obj_Unbound)),
  728.           FALSE, obj_ObjectClass, find_c_function);
  729.     define_method("find-c-pointer",
  730.           list1(obj_ByteStringClass), FALSE,
  731.           list1(pair(symbol("file"), obj_Unbound)),
  732.           FALSE, obj_ObjectClass, find_c_ptr);
  733.     define_method("load-object-file",
  734.           list1(obj_ListClass), FALSE,
  735.           list1(pair(symbol("include"), obj_Nil)), FALSE,
  736.           obj_ObjectClass, load_c_file);
  737.     define_method("signed-byte-at", list1(obj_CPointerClass), FALSE,
  738.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  739.           obj_IntegerClass, signed_byte_at);
  740.     define_method("signed-byte-at-setter",
  741.           list2(obj_IntegerClass, obj_CPointerClass), FALSE,
  742.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  743.           obj_IntegerClass, signed_byte_at_setter);
  744.     define_method("unsigned-byte-at", list1(obj_CPointerClass), FALSE,
  745.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  746.           obj_IntegerClass, unsigned_byte_at);
  747.     define_method("unsigned-byte-at-setter",
  748.           list2(obj_IntegerClass, obj_CPointerClass), FALSE,
  749.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  750.           obj_IntegerClass, unsigned_byte_at_setter);
  751.     define_method("signed-short-at", list1(obj_CPointerClass), FALSE,
  752.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  753.           obj_IntegerClass, signed_short_at);
  754.     define_method("signed-short-at-setter",
  755.           list2(obj_IntegerClass, obj_CPointerClass), FALSE,
  756.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  757.           obj_IntegerClass, signed_short_at_setter);
  758.     define_method("unsigned-short-at", list1(obj_CPointerClass), FALSE,
  759.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  760.           obj_IntegerClass, unsigned_short_at);
  761.     define_method("unsigned-short-at-setter",
  762.           list2(obj_IntegerClass, obj_CPointerClass), FALSE,
  763.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  764.           obj_IntegerClass, unsigned_short_at_setter);
  765.     define_method("signed-long-at", list1(obj_CPointerClass), FALSE,
  766.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  767.           obj_IntegerClass, signed_long_at);
  768.     define_method("signed-long-at-setter",
  769.           list2(obj_IntegerClass, obj_CPointerClass), FALSE,
  770.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  771.           obj_IntegerClass, signed_long_at_setter);
  772.     define_method("unsigned-long-at", list1(obj_CPointerClass), FALSE,
  773.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  774.           obj_IntegerClass, unsigned_long_at);
  775.     define_method("unsigned-long-at-setter",
  776.           list2(obj_IntegerClass, obj_CPointerClass), FALSE,
  777.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  778.           obj_IntegerClass, unsigned_long_at_setter);
  779.     define_method("pointer-at", list1(obj_CPointerClass), FALSE,
  780.           list2(pair(symbol("offset"), make_fixnum(0)),
  781.             pair(symbol("class"), obj_CPointerClass)), FALSE,
  782.           obj_IntegerClass, pointer_at);
  783.     define_method("pointer-at-setter",
  784.           list2(obj_CPointerClass, obj_CPointerClass), FALSE,
  785.           list1(pair(symbol("offset"), make_fixnum(0))), FALSE,
  786.           obj_IntegerClass, pointer_at_setter);
  787.     define_method("+", list2(obj_CPointerClass, obj_IntegerClass), FALSE,
  788.           obj_False, FALSE, obj_CPointerClass, pointer_add);
  789.     define_method("-", list2(obj_CPointerClass, obj_CPointerClass), FALSE,
  790.           obj_False, FALSE, obj_IntegerClass, pointer_subtract);
  791.     define_method("c-pointer-slot",
  792.           listn(4, obj_CPointerClass, obj_IntegerClass,
  793.             obj_TypeClass, obj_ObjectClass),
  794.           FALSE, obj_False, FALSE,
  795.           obj_ObjectClass, c_pointer_field);
  796.     define_method("c-pointer-slot-setter",
  797.           list3(obj_ObjectClass, obj_CPointerClass, obj_IntegerClass),
  798.           FALSE, obj_False, FALSE,
  799.           obj_ObjectClass, c_pointer_field_setter);
  800.     define_method("as",
  801.           list2(obj_StaticTypeClass, obj_CPointerClass), FALSE,
  802.           obj_False, FALSE,
  803.           obj_ObjectClass, c_pointer_as);
  804.     define_method("as",
  805.           list2(obj_IntegerClass, obj_CPointerClass), FALSE,
  806.           obj_False, FALSE,
  807.           obj_ObjectClass, c_ptr_as_int);
  808.     define_method("as",
  809.           list2(obj_StaticTypeClass, obj_IntegerClass), FALSE,
  810.           obj_False, FALSE,
  811.           obj_ObjectClass, c_int_as_ptr);
  812.     define_method("=", list2(obj_CPointerClass, obj_CPointerClass),
  813.           FALSE, obj_False, FALSE,
  814.           obj_BooleanClass, c_pointer_equal);
  815.     obj_NullPointer = make_c_pointer(obj_CPointerClass, 0);
  816.     define_constant("null-pointer", obj_NullPointer);
  817. }
  818.